home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr48 / pas_0593.zip / GHOSTED.PAS < prev    next >
Pascal/Delphi Source File  |  1993-05-08  |  10KB  |  378 lines
  1. {─ Fido Pascal Conference ────────────────────────────────────────────── PASCAL ─
  2. Msg  : 604 of 775
  3. From : Sean Palmer                         1:104/123.0          06 May 93  16:25
  4. To   : Tal Roza
  5. Subj : Ghost Editor          1/
  6. ────────────────────────────────────────────────────────────────────────────────
  7. TR>Can anyone (please, it's important) , post here an example of a source code
  8. TR>that will show a text file , and let me scroll it (Up , Down ) ?
  9. TR>Also I need an example of a simple editor.
  10.  
  11. Try this for an example. Turbo Pascal 6.0+ source.
  12. Compiles to a 7K text editor. Neat?}
  13.  
  14. {$A-,B-,D-,E-,F-,G-,I-,L-,N-,O-,R-,S-,V-,X+}
  15. {$M $C00,0,0}
  16. program ghostEd; {Ghost Editor v0.4 (C) 1993 Sean L. Palmer}
  17. const
  18.  version='0.4';
  19.  maxF=$3FFF;     {only handles small files!}
  20.  txtColor=$B;
  21.  vSeg:word=$B800;
  22. var
  23.  nLines:byte;
  24.  halfPage:byte;
  25.  txt:array[0..maxF]of char;
  26.  crs,endF,pgBase,lnBase:integer;
  27.  x,y:word;
  28.  update:boolean;
  29.  theFile:file;
  30.  ticks:word absolute $40:$6C;   {ticks happen 18.2 times/second}
  31.  
  32. procedure syncTick;var i:word;begin i:=ticks;repeat until i<>ticks;end;
  33.  
  34. function readKey:char;assembler;asm mov ah,$07; int $21; end;
  35.  
  36. function keyPressed:boolean;assembler;asm mov ah,$B; int $21; and al,$FE; end;
  37.  
  38. procedure moveScrUp(s,d,n:word);assembler;asm
  39.  mov cx,n;
  40.  push ds;
  41.  mov ax,vSeg; mov es,ax; mov ds,ax;
  42.  mov si,s; shl si,1;
  43.  mov di,d; shl di,1;
  44.  cld; repz movsw; {attr too!}
  45.  pop ds; @X:
  46.  end;
  47.  
  48. procedure moveScrDn(s,d,n:word);assembler;asm
  49.  mov cx,n;
  50.  push ds;
  51.  mov ax,vSeg; mov es,ax; mov ds,ax;
  52.  mov si,s; add si,cx; shl si,1;
  53.  mov di,d; add di,cx; shl di,1;
  54.  std; repz movsw; {attr too!}
  55.  pop ds; @X:
  56.  end;
  57.  
  58. procedure moveScr(var s;d,n:word);assembler;asm
  59.  mov cx,n; jcxz @X;
  60.  push ds;
  61.  mov ax,vSeg; mov es,ax;
  62.  mov di,d; shl di,1;
  63.  lds si,s;
  64.  cld;
  65. @L: movsb; inc di; loop @L;
  66.  pop ds; @X:
  67.  end;
  68.  
  69. procedure fillScr(d,n:word;c:char);assembler;asm
  70.  mov cx,n; jcxz @X;
  71.  mov ax,vSeg; mov es,ax;
  72.  mov di,d; shl di,1;
  73.  mov al,c; cld;
  74. @L: stosb; inc di; loop @L;
  75. @X:
  76.  end;
  77.  
  78. procedure fillAttr(d,n:word;c:byte);assembler;asm
  79.  mov cx,n; jcxz @X;
  80.  mov ax,vSeg; mov es,ax;
  81.  mov di,d; shl di,1;
  82.  mov al,c; cld;
  83. @L: inc di; stosb; loop @L;
  84. @X:
  85.  end;
  86.  
  87. procedure cls;begin
  88.  fillAttr(80,pred(nLines)*80,txtColor);
  89.  fillScr(80,pred(nLines)*80,' ');
  90.  end;
  91.  
  92. procedure scrollUp;begin
  93.  moveScrUp(320,160,pred(nLines)*160);
  94.  fillScr(pred(nLines)*160,80,' ');
  95.  end;
  96. procedure scrollDn;begin
  97.  moveScrDn(160,320,pred(nLines)*320);
  98.  fillScr(160,80,' ');
  99.  end;
  100.  
  101. {put cursor after preceding CR or at 0}
  102. function scanCrUp(i:integer):integer;assembler;asm
  103.  mov di,i; mov cx,di; add di,offset txt
  104.  mov ax,ds; mov es,ax;
  105.  std; mov al,$D;
  106.  dec di;
  107.  repnz scasb;
  108.  jnz @S; inc di; @S:
  109.  inc di;
  110.  sub di,offset txt;
  111.  mov ax,di;
  112.  end;
  113.  
  114. {put cursor on next CR or endF}
  115. function scanCrDn(i:integer):integer;assembler;asm
  116.  mov di,i; mov cx,endF;
  117.  sub cx,di; inc cx; add di,offset txt;
  118.  mov ax,ds; mov es,ax;
  119.  cld; mov al,$D;
  120.  repnz scasb;
  121.  dec di;
  122.  sub di,offset txt;
  123.  mov ax,di;
  124.  end;
  125.  
  126. procedure findxy;begin
  127.  lnBase:=scanCrUp(crs);x:=crs-lnBase;
  128.  y:=1;pgBase:=lnBase;
  129.  while(pgBase>0)and(y<halfPage) do begin
  130.   pgBase:=scanCrUp(pred(pgBase)); inc(y);
  131.   end;
  132.  end;
  133.  
  134. procedure display;var i,j,k,oldY:integer;begin
  135.  findXY;
  136.  if update then begin
  137.   update:=false;
  138.   j:=pgBase;i:=1;
  139.   while (j<=endf) and (i<pred(nLines)) do begin
  140.    k:=scanCrDn(j);
  141.    moveScr(txt[j],i*80,k-j);
  142.    fillScr(i*80+k-j,80-k+j,' ');
  143.    fillAttr(i*80,80,txtColor);
  144.    j:=succ(k); inc(i);
  145.    end;
  146.   if i<pred(nLines) then begin
  147.    fillScr(i*80,80*pred(nLines-i),'X');
  148.    fillAttr(i*80,80*pred(nLines-i),1);
  149.    end;
  150.   end
  151.  else begin
  152.   i:=scanCrDn(lnBase)-lnBase;
  153.   moveScr(txt[lnBase],y*80,i);
  154.   fillScr(y*80+i,80-i,' ');
  155.   end;
  156.  end;
  157.  
  158. const menuStr:string='Ghost Editor v'+version+'-(C) Sean Palmer 1993';
  159. procedure title;begin
  160.  fillAttr(0,80,$70);fillScr(0,80,' ');
  161.  MoveScr(MenuStr[1],1,length(MenuStr));
  162.  end;
  163.  
  164. procedure error(s:string);begin
  165.  fillattr(0,80,$CE);fillScr(0,80,' ');
  166.  moveScr(s[1],1,length(s));
  167.  write(^G);readkey;
  168.  title;
  169.  end;
  170.  
  171. procedure tooBigErr;begin error('File too big');end;
  172.  
  173. procedure insChar(c:char);forward;
  174. procedure delChar;forward;
  175. procedure backChar;forward;
  176.  
  177. procedure trimLine;var i,t,b:integer;begin
  178.  i:=crs;
  179.  b:=scanCrDn(crs); t:=scanCrUp(crs);
  180.  crs:=b;
  181.  while txt[crs]=' ' do begin
  182.   delchar;
  183.   if i>crs then dec(i);
  184.   if crs>0 then dec(crs);
  185.   end;
  186.  crs:=i;
  187.  end;
  188.  
  189. procedure checkWrap(c:integer);var i,t,b:integer;begin
  190.  b:=scanCrDn(c); t:=scanCrUp(c);
  191.  i:=b;
  192.  if i-t>=79 then begin
  193.   i:=t+79;
  194.   repeat dec(i); until (txt[i]=' ')or(i=t);
  195.   if i=t then backChar   {just disallow lines that long with no spaces}
  196.   else begin
  197.    txt[i]:=^M;  {change sp into cr, to wrap}
  198.    update:=true;
  199.    if (b<endF)and(txt[b]=^M)and(txt[succ(b)]<>^M) then begin
  200.     txt[b]:=' '; {change cr into sp, to append wrapped part to next line}
  201.     checkWrap(b); {recursively check next line since it got stuff added}
  202.     end;
  203.    end;
  204.   end;
  205.  end;
  206.  
  207. procedure changeLines;begin
  208.  trimLine; update:=true;  {signal to display to redraw}
  209.  end;
  210.  
  211. procedure insChar(c:char);begin
  212.  if endf=maxF then begin tooBigErr;exit;end;
  213.  move(txt[crs],txt[succ(crs)],endf-crs);
  214.  txt[crs]:=c;inc(crs);inc(endf);
  215.  if c=^M then changeLines;
  216.  checkWrap(crs);
  217.  end;
  218. procedure delChar;begin
  219.  if crs=endf then exit;
  220.  if txt[crs]=^M then changeLines;
  221.  move(txt[succ(crs)],txt[crs],endf-crs);
  222.  dec(endf);
  223.  checkWrap(crs);
  224.  end;
  225.  
  226. procedure addLF;var i:integer;begin
  227.  for crs:=endF downto 1 do if txt[pred(crs)]=^M then begin
  228.   insChar(^J); dec(crs);
  229.   end;
  230.  end;
  231.  
  232. procedure stripLF;var i:integer;begin
  233.  for crs:=endF downto 0 do if txt[crs]=^J then delChar;
  234.  end;
  235.  
  236. procedure writeErr;begin error('Write Error');end;
  237.  
  238. procedure saveFile;begin
  239.  addLF;
  240.  rewrite(theFile,1);
  241.  if ioresult<>0 then writeErr
  242.  else begin
  243.   blockwrite(theFile,txt,endf);
  244.   if ioresult<>0 then writeErr;
  245.   close(theFile);
  246.   end;
  247.  end;
  248.  
  249. procedure newFile;begin crs:=0;endF:=0;update:=true;end;
  250.  
  251. procedure readErr;begin error('Read Error');end;
  252.  
  253. procedure loadFile;var i,n:integer;begin
  254.  reset(theFile,1);
  255.  if ioresult<>0 then newFile
  256.  else begin
  257.   n:=filesize(theFile);if n>maxF then begin tooBigErr;n:=maxF;end;
  258.   blockread(theFile,txt,n,i);if i<n then readErr;
  259.   close(theFile);
  260.   crs:=0;endf:=i;update:=true;
  261.   stripLF;
  262.   end;
  263.  end;
  264.  
  265. procedure signOff;var f:file;i,n:integer;begin
  266.  assign(f,'signoff.txt');
  267.  reset(f,1);
  268.  if ioresult<>0 then error('No SIGNOFF.TXT defined')  {no macro defined}
  269.  else begin
  270.   n:=filesize(f);
  271.   blockread(f,txt[endF],n,i);if i<n then readErr;
  272.   close(f);
  273.   inc(endf,i);update:=true;
  274.   i:=crs; stripLF; crs:=i; {stripLF messes with crs}
  275.   end;
  276.  end;
  277.  
  278. procedure goLf;begin
  279.  if crs>0 then dec(crs);
  280.  if txt[crs]=^M then changeLines;
  281.  end;
  282. procedure goRt;begin
  283.  if txt[crs]=^M then changeLines;
  284.  if crs<endf then inc(crs);
  285.  end;
  286. procedure goCtrlLf;var c:char;begin
  287.  repeat goLf;c:=txt[crs];until (c<=' ')or(crs=0);
  288.  end;
  289. procedure goCtrlRt;var c:char;begin
  290.  repeat goRt;c:=txt[crs];until (c<=' ')or(crs>=endF);
  291.  end;
  292. procedure goUp;var i:integer;begin
  293.  if lnBase>0 then begin
  294.   changeLines;
  295.   lnBase:=scanCrUp(pred(lnBase));crs:=lnBase;
  296.   i:=scanCrDn(crs)-crs;
  297.   if i>=x then inc(crs,x) else inc(crs,i);
  298.   end;
  299.  end;
  300. procedure goDn;var i:integer;begin
  301.  changeLines;
  302.  crs:=scanCrDn(crs);if crs>=endF then exit;
  303.  inc(crs);lnBase:=crs;
  304.  i:=scanCrDn(crs)-crs;
  305.  if i>=x then inc(crs,x) else inc(crs,i);
  306.  end;
  307. procedure goPgUp;var i:byte;begin for i:=halfPage downto 0 do goUp; end;
  308. procedure goPgDn;var i:byte;begin for i:=halfPage downto 0 do goDn; end;
  309. procedure goHome;begin crs:=scanCrUp(crs); end;
  310. procedure goEnd;begin crs:=scanCrDn(crs); end;
  311.  
  312. procedure backChar;begin
  313.  if (crs>0) then begin goLf; delChar; end;
  314.  end;
  315.  
  316. procedure deleteLine;var i:integer;begin
  317.  i:=scanCrDn(crs);crs:=scanCrUp(crs);
  318.  if i<endF then begin move(txt[succ(i)],txt[crs],endf-i); dec(endF);end;
  319.  dec(endf,i-crs); changeLines;
  320.  end;
  321.  
  322. procedure flipCursor;var j,k,l:word;begin
  323.  j:=succ((y*80+x)shl 1);
  324.  l:=mem[vSeg:j];   {save attr under cursor}
  325.  mem[vSeg:j]:=$7B; if not keypressed then syncTick;
  326.  mem[vSeg:j]:=l; if not keypressed then syncTick;
  327.  end;
  328.  
  329. procedure edit;var c:char;begin
  330.  repeat
  331.   display;
  332.   repeat flipcursor;until keypressed;
  333.   c:=readkey;
  334.   if c=#0 then case readkey of
  335.    #59:signOff;
  336.    #75:goLf;
  337.    #77:goRt;
  338.    #115:goCtrlLf;
  339.    #116:goCtrlRt;
  340.    #72:goUp;
  341.    #80:goDn;
  342.    #83:delChar;
  343.    #73:goPgUp;
  344.    #81:goPgDn;
  345.    #71:goHome;
  346.    #79:goEnd;
  347.    end
  348.   else case c of
  349.    ^[:saveFile;
  350.    ^H:backChar;
  351.    ^C:{abortFile};
  352.    ^Y:deleteLine;
  353.    else insChar(c);
  354.    end;
  355.   until (c=^[)or(c=^C);
  356.  end;
  357.  
  358. function getRows:byte;assembler;asm
  359.  mov ax,$1130; xor dx,dx; int $10;
  360.  or dx,dx; jnz @S; mov dx,24; @S: {cga/mda don't have this fn}
  361.  inc dx; mov al,dl;
  362.  end;
  363.  
  364. var oldMode:byte;
  365. begin
  366.  asm mov ah,$F; int $10; mov oldMode,al; end;  {save old Gr mode}
  367.  if oldMode=7 then vSeg:=$B000;  {check for Mono}
  368.  nLines:=getRows;
  369.  halfPage:=pred(nLines shr 1);
  370.  cls; title;
  371.  if paramCount=0 then error('Need filename as parameter')
  372.  else begin
  373.   asm mov bh,0; mov dl,0; mov dh,nLines; mov ah,2; int $10; end; {put cursor of}
  374.   assign(theFile,paramStr(1));
  375.   loadFile;
  376.   edit;
  377.   end;
  378.  end.